 ;;########################################################################
;; reportw.lsp
;; Copyright (c) 1998-9 by Forrest W. Young
;; Creates a window for displaying reports. 
;; Uses display-window-proto2 (on mac uses display-window-proto)
;;########################################################################


(defun report-file
  (filename &key (title nil) (wrap nil) (flow nil) (page nil) (scroll nil) (size '(475 280)) (location '(150 150)) (show t) (container nil) (listener nil) (free t) (local-menus t) (pop-out t) (top-most nil) (fit t) (help nil) (color nil))

"args: (filename &key (title nil) (wrap nil) (flow nil) (page nil) (scroll nil) (size '(475 280)) (location '(150 150)) (show t) (container nil) (listener nil) (free t) (local-menus t) (pop-out t) (top-most nil) (fit t) (help nil) (color nil)
Gets text from filename and displays in window. By default there is no wrapping, formatting, paging or scrolling. Other arguments are as used elsewhere."

  (let* ((height))
    (setf title (if title title (strcat "ViSta File: " filename)))
    (unless color (setf color (if help 'post-it-yellow 'white)))
    (setf w (report-header title :page page :size size :location location :show nil
                           :container container :listener listener :free free 
                           :local-menus local-menus :pop-out nil :nowrap (not wrap) 
                           :noformat (not flow) :top-most top-most :scroll scroll 
                           :page page :fit nil  :color color))
    (with-open-file (g filename) (send w :paste-stream g))
    (send w :scroll 0 0)
    (setf *current-text-window* w)
    (when (and show (> (send w :nlines) 0)) 
          (when fit (send w :window-size-adjustment));works here!
          ;to show window, must do following, in order, or else segment violation
          (send w :front-window)
          (send w :pop-out t))
    w))

(defun report-window
  (title &key (size '(475 280)) (location '(150 150)) (show t) 
         container (listener nil) (free t) local-menus (pop-out t)
         (nowrap t) (noformat t) (top-most nil) (page nil) (scroll nil) (fit nil))
"Function ARGS: title &key page (size '(475 280)) (location '(150 150)) (show t) container listener free local-menus pop-out (nowrap t) (noformat t) (top-most nil) (page nil) (fit nil) 
Creates a new report window. Report window is a pseudo-listener if LISTENER is T, a display window if NIL. CONTAINER FREE LOCAL-MENUS and POP-OUT effective only in a container environment. LISTENER only effective under ms-windows. PAGE NOWRAP and NOFORMAT ignored when LISTENER is T."
         (send *vista* :report-window title show size location page scroll
               container free local-menus pop-out
               nowrap noformat top-most fit listener))


(defun report-header
  (title &key page (size '(475 280)) (location '(150 150)) 
         (show t) container (listener nil) (free t) local-menus 
         (pop-out t) (nowrap t) (noformat t) (top-most nil) 
         (scroll nil) (page nil) (fit nil))
"Alias of report-window function."
         (send *vista* :report-window title show size location page scroll 
               container free local-menus pop-out nowrap noformat top-most fit listener))



(defmeth vista-system-object-proto :report-window (title show &optional (size '(475 280)) (location '(150 150)) page scroll container (free t) (local-menus t) (pop-out t) (nowrap t) (noformat t) (top-most nil) fit (listener nil))
  
  (let* ((existing-container *active-container*)
         (L (send self :report-window-id-list))
         (w)
         )
    (unless existing-container 
            (enable-container *desktop-container*)
            (setf existing-container *desktop-container*))

    (setf w (if listener 
                (send listener-proto 
                      :new :title title 
                      :size size :location location)
                (display-window "" :report t
                     :title title :show show :size size :location location
                     :page page :scroll scroll :container container :free free 
                     :local-menus local-menus :pop-out pop-out :nowrap nowrap
                     :noformat noformat :top-most top-most :fit fit)))
;note for large data listener is much faster, but top portion gets lost
    (cond
      (listener
       (send w :pop-out t)
       (send w :no-move nil)
       (defmeth w :fit-window-to-text ())
       (defmeth w :paste-string (str)
         (format t "~a" str))
       )
      (t
       (send w :flush-window)
       (send w :initialize w t scroll)
       (when fit (send self :fit-window-to-text))
       (apply #'send w :frame-size size)
       ))

    (setf *display-window* w)
    (setf *display-container* w)
    (if L  (send self :report-window-id-list (combine L w))
        (send self :report-window-id-list (list w)))
    (if existing-container 
        (enable-container existing-container)
        (disable-container))
    (send w :original-height (second size))
    (send *click-close-menu-item* :enabled nil)
    (send *click-close-menu-item* :mark nil)
    (defmeth w :do-click (x y m1 m2) (call-next-method x y m1 m2))
    w))


(defun make-new-report-window-proto2-instance 
  (&key (title "Display Window") (size '(475 280)) (location '(150 150)) (show t) 
        (free t) (local-menus t) (container *desktop-container*) 
        (pop-out t) (nowrap t) (noformat t) (top-most nil) (page nil) (fit nil))
"Args &KEY TITLE SIZE LOCATION SHOW (LOCAL-MENUS T) (NOWRAP T) (NOFORMAT T) (FREE T) (CONTAINER *desktop-container*) (POP-OUT T) (TOP-MOST NIL) (PAGE NIL) (FIT NIL)
Uses display-window-proto2 :isnew method to make a new instance, with optional control of container in which it appears. The default values of LOCAL-MENUS, POP-OUT TOP-MOST and CONTAINERS make the text window appear on its own with a menu bar and menu. The window is popped-out of *desktop-container* on top of all other windows.  If POP-OUT is NIL the window appears in Main Window unless CONTAINER is specified. Returns window (not container) objid and creates two global variables *display-window* and *display-container*"
  (let ((existing-container *active-container*)
        (w nil)(c nil))

    (setf c (cond
              (container (enable-container container))
              (*active-container* (enable-container *active-container*))
              (t (make-container :title title :type 7 :show nil 
                                :free free :local-menus local-menus))))

    (setf w (send report-window-proto :new :title title :size size 
                  :top-most top-most :pop-out pop-out :page page
                 :location location :show show :nowrap nowrap :noformat noformat))

    (send w :add-slot 'container)

    (defmeth w :container (&optional (objid nil set))
      (if set (setf (slot-value 'container) objid))
      (slot-value 'container))
    (send w :container c)
   ; (setf pop-out (if (< (min (send c :size)) 0) t pop-out))
    (when show 
          (send c :show-window)
          (send w :pop-out pop-out))
    (send w :top-most top-most)
   ; (apply #'send w :location location)
    (setf *display-window* w)
    (setf *display-container* w)
    (if existing-container 
        (enable-container existing-container)
        (disable-container))
    (when fit (send self :fit-window-to-text))
    (send w :original-height (second size))
    w))
 
(defproto report-window-proto '(max-line-width page resizing container original-height) ()
display-window-proto2)

(defmeth report-window-proto :isnew (&rest args)
  (apply #'call-next-method args)
  (send self :pop-out-on-show nil))
  

(defmeth report-window-proto :initialize (w page scroll)
  (send w :max-line-width 0)
  (send w :nowrap nil)
  (send w :noformat t)
  (send w :page t)
  (send w :scroll))

(defmeth report-window-proto :max-line-width (&optional (number nil
set))
  (if set (setf (slot-value 'max-line-width) number))
  (slot-value 'max-line-width))

(defmeth report-window-proto :original-height (&optional (number nil set))
  (if set (setf (slot-value 'original-height) number))
  (slot-value 'original-height))

(defmeth report-window-proto :page (&optional (logical nil set))
  (if set (setf (slot-value 'page) logical))
  (slot-value 'page))

(defmeth report-window-proto :resizing (&optional (logical nil set))
  (if set (setf (slot-value 'resizing) logical))
  (slot-value 'resizing))

(defmeth report-window-proto :container (&optional (objid nil set))
  (if set (setf (slot-value 'container) objid))
  (slot-value 'container))

(defun display-string (string &optional (w nil))
"Function args: (string &optional (w nil))
Writes string to display-window w if w specified, otherwise to
listener."
  (if w (send w :paste-string string)
      (format t "~a" string))
 ; (if w (send w :resize))
  nil)

;mac-only version of next two function/methods in function.lsp!

;#+macintosh(defmeth display-window-proto :fit-window-to-text ())

;#+macintosh(defmeth display-window-proto :scroll (&rest args))

(defun right-justify-string (string field-width)
  (let ((field-width-seq (iseq field-width)))
    (cond ((< (length string) field-width)
           (setf string (strcat (make-string field-width) string))
           (setf string (reverse (select (reverse string) 
                                         field-width-seq))))
      ((= (length string) field-width))
      (t
       (setf string (select string field-width-seq))))
    string))

(defmeth report-window-proto :paste-string (string &key (newlines t))
  (let* ((page (send self :page))
         (scroll (send self :scroll))
         (nlines (send self :nlines))
         (wheight (send self :original-height))
         (wlines))
    (unless wheight (send self :original-height 280)
            (setf wheight 280))
    (when wheight
          (setf wlines (floor (/ wheight (send self :line-height))))
          (call-next-method string :newlines newlines)
          (send self :scroll 0 (+ (second (send self :scroll)) 
                                        (* wlines (send self :line-height))))
          (when (and page (= 0 (mod (1+ nlines) wlines)))
                (send self :fit-window-to-text :vertical-only t)
               ; (send self :scroll 0 (+ (second (send self :scroll)) 
                ;                        (* wlines (send self :line-height))))
                (send self :original-height 
                      (min (+ 280 (send self :original-height))
                           (second (- (effective-screen-size) (send self :location)))))                        ;(send self :redraw)
                ))))
;=======
;
;(defmeth report-window-proto :paste-string (string &key (newlines t))
;  (call-next-method string :newlines newlines))
;>>>>>>> 1.6


(defmeth report-window-proto :window-size-adjustment ()
  (let ((num-screen-lines 
         (1+ (floor (/ (second (send self :size)) 
                   (send self :line-height)))))
        (num-screen-lines 
         (floor (/ (second (send self :size)) 
                   (send self :line-height))))
        (page (send self :page))
        (scroll (send self :scroll))
        (temp (mapcar #'(lambda (text)
                                    (send self :text-width text))
                                (send self :lines)))
        )
    (send self :max-line-width 
          (if (send self :max-line-width)
              (max (combine (send self :max-line-width) temp))
              (max temp)))
    (when (send self :max-line-width)
          (if (< (send self :max-line-width) (- (first (send self :size)) ) )
              (send self :has-h-scroll nil)
              (send self :has-h-scroll (+ 80 (send self :max-line-width)))
              ))

    (when (> (* (+ 2 (send self :nlines)) (send self :line-height))
             (second (send self :size)))
          (send self :has-v-scroll (* (+ 2 (send self :nlines))
                                      (send self :line-height)))
          (when scroll 
                (send self :scroll 0 (+ (second (send self :scroll)) 1)))
          (when page
              (send self :scroll 0 (+ (second (send self :scroll)) 
                                      (* num-screen-lines
                                         (send self :line-height))))))
    (cond
      (scroll
       (send self :fit-window-to-text :vertical-only t :window-size nil)
       (send self :scroll 0 (+ (second (send self :scroll)) 1))
       (send self :redraw)
       )
      (and page (= 0 (mod (send self :nlines) num-screen-lines)))
          (send self :fit-window-to-text :vertical-only t :window-size nil)
          (send self :scroll 0 (+ (second (send self :scroll)) 
                                  (* num-screen-lines
                                     (send self :line-height))))
      (send self :redraw)
      )
    ))


(defmeth report-window-proto :fit-window-to-text (&key (vertical-only nil) (window-size t))
  (when window-size (send self :window-size-adjustment ))
  (let* ((nlines (send self :nlines))
         (line-height (send self :line-height))
         (window-height (+ 13 (* (1+ nlines) line-height)));13
         (dwh (send self :default-window-height))
         (window-width (+ (first (send self :size)) 4));4
         (ww  (+ 88 (send self :max-line-width))));88
    (when (= 0 window-height) (setf window-height dwh))
    (setf x (- (+ (first (send self :location)) ww) 
               (first (effective-screen-size));(first *now-screen-size*)
               ))
    (if (> x 0) (setf ww (- ww x)))
    (setf y (- (+ (second (send self :location)) window-height) 
               (second (effective-screen-size))));(second *now-screen-size*)
    (if (> y 0) (setf window-height (- window-height y)))
    (setf window-height 
          (max (min (- (second (effective-screen-size));(send *vista* :desktop-size)
                       (second (send self :frame-location)) 8)
                    window-height)
               dwh))
    (setf ww (if vertical-only window-width (max window-width ww)))
    (send self :size (- ww 4) (max dwh window-height)) ;(- ww 4) window-height
    ))
  
(defmeth report-window-proto :redraw ()
  (when (not (send self :reformatting))
  (when (send *vista* :ready-to-redraw self)
        (send self :erase-window)
        (let* ((y-top (second (send self :view-rect)))
               (y-now nil)
               (y-bot (+ y-top (fourth (send self :view-rect)))))
          (dotimes (i (length (send self :y-list)))
                   (setf y-now (select (send self :y-list) i))
                   (cond
                     ((<= y-top y-now y-bot)
                      (send self :draw-text 
                            (select (send self :lines) i)
                            (select (send self :x-list) i) y-now 0 1))
                     ((> y-now y-bot)
                      (return)))))
        (send *vista* :finished-redraw self)))
        )


        
(defmeth report-window-proto :resize ()
  (when (not (send self :resizing))
        (send self :resizing t)
        ;(send self :scroll 0 0)
        (when (send self :max-line-width)
              (if (< (send self :max-line-width) (- (first (send self :size))
                                                    ) )
                  (send self :has-h-scroll nil)
                  (send self :has-h-scroll (+ 80 (send self
                                                       :max-line-width)))
                  ))
        (if (> (* (+ 2 (send self :nlines)) (send self :line-height))
               (second (send self :size)))
            (send self :has-v-scroll (* (+ 3 (send self :nlines)) ;2
                                        (send self :line-height)))
            (send self :has-v-scroll nil)) 
        (send self :redraw)
        (send self :resizing nil)))




;fwy aug 25 fixed print-matrix to print to listener
;;########################################################################
;;print-matrix and print-matrix-to-window from reportw
;;########################################################################



(defun print-matrix (matrix &optional (decimals 2) &rest args &key show (print t))
"Args: (matrix  &optional (decimals 2) &key (show nil) (display t) row-labels labels col-labels column-labels (row-heading \"Observations\") (column-heading \"Variables\") var-types variable-types types)
Displays MATRIX in listener (or window) in a nice format with DECIMALS places after the decimal. By default, shows the matrix in listener unless DISPLAY is NIL, and in a separate window when SHOW is T. Displays row labels when the :ROW-LABELS (or :LABELS) keyword is followed by a list of labels. Displays column labels when the :COLUMN-LABELS (or :COL-LABELS) keyword is followed by a list of labels. Displays row and column headings when :ROW-HEADING and :COLUMN-HEADING (or :COL-HEADING) are used. When column labels are displayed, also displays variable types when :VARIABLE-TYPES (or :VAR-TYPES OR :TYPES) is followed by a list of variable type strings. Modified by FWY from LT's print-matrix function."
(apply #'print-matrix-to-window matrix nil :decimals decimals 
                  :print print :show show args))

(defun pms (matrix-list) 
"Args: MATRIX-LIST
Prints each matrix in a list of matrices using the pm function."
  (mapcar #'pm matrix-list) 
  t)


(defun pm (a) (print-matrix-to-window a nil :print t :show nil))


(defun pmw (&rest args)
  (apply #'print-matrix-to-window args))

(defun print-matrix-to-window (a window-object &key row-labels column-labels types variable-types var-types (row-heading "Observations") (column-heading "Variables") col-heading labels col-labels (decimals 2) (show t) (print nil) )
"Args: (matrix window-object &key (decimals 2) row-labels column-labels row-heading column-heading var-types types print)
Displays MATRIX in WINDOW-OBJECT in a nice format with DECIMALS places after the decimal. Displays row labels when the :ROW-LABELS (or :LABELS) keyword is followed by a list of labels. Displays  column labels when the :COLUMN-LABELS (or :COL-LABELS) keyword is followed by a list of labels. Displays row and column headings when :ROW-HEADING and :COLUMN-HEADING (or :COL-HEADING) are used. When column labels are displays, also displays variable types when :VARIABLE-TYPES (or :VAR-TYPES OR :TYPES) is followed by a list of variable type strings. Creates a new window object when WINDOW-OBJECT is nil. Prints in listener when PRINT is T and WINDOW is NIL. Modified by FWY from LT's print-matrix function."
  (unless (matrixp a) (error "not a matrix - ~a" a)) 
  (let ((size 0)
        (sizea 0)
        (sizes (array-dimensions a))
        (j 0)
        (n)
        (y) (maxcol 0) (column)
        (min-col-label-length 4)
        (row-label-length)
        (col-label-length)
        (field-width)
        (buffer)) 
    (when (not window-object)
          ;fwy aug 25 added if statement and change t to show
          (if print 
              (setf window-object nil)
              (setf window-object (report-header "Print Matrix" :page t :show show)))
          ;fwy aug 25, next line was :show t
          ;(setf window-object (report-header "Print Matrix" :page t :show t))
          )
    ;(setf show print)
    (when (and (not row-labels) (not labels))
          (setf row-labels (mapcar #'(lambda (i) (format nil "Obs ~a" i)) 
                                   (1+ (iseq (first sizes))))))
    (when (and (not col-labels) (not column-labels))
          (setf col-labels (mapcar #'(lambda (i) (format nil "Var ~a" i)) 
                                   (1+ (iseq (second sizes))))))
    (when row-labels (setf labels row-labels))
    (when column-labels (setf col-labels column-labels))
    (when var-types (setf variable-types var-types))
    (when types (setf variable-types types))
    (when variable-types (setf min-col-label-length 8))
    (dotimes (i (length (row a 0)))   
             (setf column (non-missing (col a i)));PV added non-missing
             (cond 
               ((not (stringp (select column 0)))
                (setf maxcol (max maxcol (abs column)))
                (setf size (max size (+ 4 (flatsize (round (max (abs column))))))))
               (t
                (setf sizea (max (mapcar #'length (coerce column 'list)))))))  
    (setf size (max size sizea))
    (setf maxcol (max maxcol sizea))
    (if (and (/= maxcol 0)(< maxcol 10)) (setf size (1+ size)))
    (setf decimals+size  (max (+ decimals size) min-col-label-length))
    (setf decimals+sizea decimals+size)
    (setf iseq!decimals+size (iseq decimals+size))
    (setf row-heading (select (strcat row-heading (make-string 12)) (iseq 12)))
    (when labels
          (setf row-label-length 14) ;(min 12 (max (mapcar #'length labels)))
          (setf labels
                (mapcar #'(lambda (label)
                            (setf label (strcat label (make-string row-label-length)))
                            (setf label (select label (iseq row-label-length))))
                        labels)))
    (setf buffer (right-justify-string 
                  (string-upcase column-heading)
                  (+ decimals+size 14
                     (- (length column-heading)
                        (length (first col-labels))))))
    (show-pm-buffer window-object buffer)
    (show-pm-buffer window-object (format nil "~%"))
    ; (send window-object :paste-string buffer)
    ; (send window-object :paste-string (format nil "~%"))
    (when row-labels 
          (if (not variable-types)
              (setf buffer 
                    (strcat ;(format nil "~%") 
                            (string-upcase row-heading) 
                            (make-string (- row-label-length 12))))
              (setf buffer "              "))
          (mapcar #'(lambda (label)
                      (setf buffer (strcat buffer 
                                           (format nil "~a " (right-justify-string
                                                              label decimals+size)))))
                  col-labels)
          (show-pm-buffer window-object buffer)
          ;(send window-object :paste-string buffer)
          )
    

    (when variable-types 
          (setf buffer 
                (strcat (format nil "~%") 
                        (string-upcase row-heading) 
                        (make-string (- row-label-length 12)))))
    (when col-labels
          (setf col-label-length 14)
          (when variable-types
                (format nil "~%")
                (mapcar #'(lambda (type)
                            (setf buffer (strcat buffer 
                               (format nil "~a " (right-justify-string 
                                                  type decimals+size)))))
                        variable-types)
                (show-pm-buffer window-object buffer)
                ;(send window-object :paste-string buffer)
                ))
    (setf buffer (format nil "~%"))
    ; (send window-object :paste-string buffer)
    (show-pm-buffer window-object buffer)
    (dolist (x (row-list a))
            (setf n (length x))
            (setf buffer "")
            (when (not (equal labels nil))
                  (if window-object (setf buffer (strcat buffer 
                              (format nil "~a" (select labels j))))
                      (format t "~a" (select labels j)))
                  (setf j (1+ j)))
            (dotimes (i n)
                     (setf y (aref x i))
                     (cond
                       ((integerp y)
                        (if window-object
                            (setf buffer (strcat buffer 
                                 (format nil "~vd" (+ decimals size) y )))
                            (format t "~vd" (+ decimals size) y)))
                       ((floatp y)
                        (if window-object
                            (setf buffer (strcat buffer 
                                  (format nil "~v,vf" (+ decimals size) decimals y)))
                            (format t "~v,vf" (+ decimals size)
                                    decimals y)))
                       (t 
                        (if window-object
                            (setf buffer (strcat buffer 
                               (format nil "~va" (+ decimals sizea) 
                                 (reverse (select 
                                   (reverse (strcat (make-string decimals+size) y))
                                           iseq!decimals+size)))))
                            (format t "~va" decimals+sizea 
                                    y))))
                     (if (< i (- n 1))
                         (if window-object
                             (setf buffer (strcat buffer (format nil " ")))
                             (format t " ")))
                     )
            ;(send window-object :paste-string buffer)
            ;(if window-object
            ;    (send window-object :paste-string (format nil "~%"))
            ;    (format t "~%"))
            (show-pm-buffer window-object (format nil "~a~%" buffer))
            )
    window-object))

(defun show-pm-buffer (w buffer)
  (if w (send w :paste-string buffer)
      (format t "~a" buffer)))